Deaths In USA

Graphs of weekly deaths in the USA using CDC data


Prepare Data

# Prep data
ages <- c("Under 25 years", "25-44 years", "45-64 years", 
          "65-74 years", "75-84 years", "85 years and older")
pp <- read.csv("data_usa_population.csv") %>% 
  select(Area, Population=X2019) %>%
  mutate(Population = as.numeric(gsub(",","",Population)))
dd <- read.csv("data_usa_deaths.csv") %>%
  rename(Area=1, Date=Week.Ending.Date) %>%
  mutate(Date = as.Date(Date, format = "%m/%d/%Y"),
         Julian.Day = lubridate::yday(Date),
         Age.Group = factor(Age.Group, levels = ages),
         Year = as.numeric(substr(Date, 1, 4)),
         Group = ifelse(Year < 2020, "<2020", Year),
         Group = factor(Group, levels = c("<2020", "2020", "2021", "2022", "2023")))
myColors <- c("darkgreen", "darkred", "darkorange", "steelblue", "darkblue")
myCaption <- c("\u00A9 www.dblogr.com/  |  Data: CDC\nNote: recent data may be incomplete")

Weekly Deaths

# Create plotting function
deathPlot1 <- function(area = "United States") {
  # Prep data
  vv <- as.Date(c("2015-01-01","2016-01-01","2017-01-01",
                  "2018-01-01","2019-01-01","2020-01-01",
                  "2021-01-01","2022-01-01"))
  xx <- dd %>% filter(Area == area) %>% 
    group_by(Area, Date, Group) %>% 
    summarise(Value = sum(Number.of.Deaths))
  myMin <- min(xx %>% filter(Group == "<2020") %>% 
                 pull(Value), na.rm = T)
  xx <- xx %>% filter(Value > myMin)
  # Plot
  ggplot(xx, aes(x = Date, y = Value / 1000)) +
    geom_line(color = "darkred", size = 1, alpha = 0.8) +
    geom_vline(xintercept = vv, lty = 2, alpha = 0.5) +
    facet_wrap(Area ~ .) +
    scale_x_date(date_breaks = "1 year", date_labels = "%Y", 
                 minor_breaks = "1 year") +
    theme_agData() +
    labs(y = "Thousand Deaths Per Week", x = NULL, caption = myCaption)
}

United States

mp <- deathPlot1(area = "United States")
ggsave("usa_deaths_1_01.png", mp, width = 8, height = 4)

Yearly Deaths

# Create plotting function
deathPlot2 <- function(area = "United States") {
  # Prep data
  xx <- dd %>% 
    filter(Area == area) %>% 
    mutate(Year = as.numeric(substr(Date, 1, 4))) %>%
    group_by(Area, Year, Group) %>% 
    summarise(Value = sum(Number.of.Deaths))
  # Plot
  ggplot(xx, aes(x = Year, y = Value / 1000000, fill = Group, alpha = Group)) +
    geom_bar(stat = "identity", color = "black") +
    facet_wrap(Area ~ .) +
    scale_fill_manual(values = myColors) +
    scale_alpha_manual(name = NULL, values = c(0.4,0.8,0.8,0.8,0.8)) +
    scale_x_continuous(breaks = min(xx$Year):max(xx$Year)) +
    theme_agData(legend.position = "none") +
    labs(y = "Million Deaths", x = NULL, caption = myCaption)
}

United States

mp <- deathPlot2(area = "United States")
ggsave("usa_deaths_2_01.png", mp, width = 6, height = 4)

New York

mp <- deathPlot2(area = "New York")
ggsave("usa_deaths_2_02.png", mp, width = 6, height = 4)

New Jersey

mp <- deathPlot2(area = "New Jersey")
ggsave("usa_deaths_2_03.png", mp, width = 6, height = 4)

California

mp <- deathPlot2(area = "California")
ggsave("usa_deaths_2_04.png", mp, width = 6, height = 4)

Texas

mp <- deathPlot2(area = "Texas")
ggsave("usa_deaths_2_05.png", mp, width = 6, height = 4)

Florida

mp <- deathPlot2(area = "Florida")
ggsave("usa_deaths_2_06.png", mp, width = 6, height = 4)

Washington

mp <- deathPlot2(area = "Washington")
ggsave("usa_deaths_2_07.png", mp, width = 6, height = 4)

Montana

mp <- deathPlot2(area = "Montana")
ggsave("usa_deaths_2_08.png", mp, width = 6, height = 4)

North Dakota

mp <- deathPlot2(area = "North Dakota")
ggsave("usa_deaths_2_09.png", mp, width = 6, height = 4)

South Dakota

mp <- deathPlot2(area = "South Dakota")
ggsave("usa_deaths_2_10.png", mp, width = 6, height = 4)

Deaths Vs. Previous Years

# Create plotting function
deathPlot3 <- function(areas = "United States") {
  # Prep data
  xx <- dd %>% filter(Area %in% areas) %>%
    mutate(Area = factor(Area, levels = areas)) %>%
    group_by(Area, Year, Group, Date, Julian.Day) %>% 
    summarise(Value = sum(Number.of.Deaths))
  for(i in areas) {
    myMin <- min(xx %>% filter(Area == i, Group == "<2020") %>%
                   pull(Value), na.rm = T)
    xx <- xx %>% filter(!(Area == i & Value < myMin))
  }
  # Plot
  ggplot(xx, aes(x = Julian.Day, y = Value / 1000, 
                 color = Group, alpha = Group)) +
    geom_line(aes(group = Year), size = 1) +
    facet_wrap(Area ~ ., scales = "free_y", ncol = 5) +
    scale_color_manual(name = NULL, values = myColors) +
    scale_alpha_manual(name = NULL, values = c(0.4,0.8,0.8,0.8,0.8)) +
    theme_agData(legend.position = "bottom") +
    labs(x = "Julian Day", y = "Thousand Deaths Per Week", 
         caption = myCaption)
}

United States

mp <- deathPlot3(areas = "United States")
ggsave("usa_deaths_3_01.png", mp, width = 6, height = 4)
ggsave("featured.png", mp, width = 6, height = 4)
ggsave("../../posts_blog/usa_deaths/featured.png", mp, width = 6, height = 4)

New York

mp <- deathPlot3(areas = "New York")
ggsave("usa_deaths_3_02.png", mp, width = 6, height = 4)

New Jersey

mp <- deathPlot3(areas = "New Jersey")
ggsave("usa_deaths_3_03.png", mp, width = 6, height = 4)

California

mp <- deathPlot3(areas = "California")
ggsave("usa_deaths_3_04.png", mp, width = 6, height = 4)

Texas

mp <- deathPlot3(areas = "Texas")
ggsave("usa_deaths_3_05.png", mp, width = 6, height = 4)

Florida

mp <- deathPlot3(areas = "Florida")
ggsave("usa_deaths_3_06.png", mp, width = 6, height = 4)

Washington

mp <- deathPlot3(areas = "Washington")
ggsave("usa_deaths_3_07.png", mp, width = 6, height = 4)

Montana

mp <- deathPlot3(areas = "Montana")
ggsave("usa_deaths_3_08.png", mp, width = 6, height = 4)

North Dakota

mp <- deathPlot3(areas = "North Dakota")
ggsave("usa_deaths_3_09.png", mp, width = 6, height = 4)

South Dakota

mp <- deathPlot3(areas = "South Dakota")
ggsave("usa_deaths_3_10.png", mp, width = 6, height = 4)

Selected States

mp <- deathPlot3(areas = c("New York", "Texas", "Montana"))
ggsave("usa_deaths_3_11.png", mp, width = 12, height = 4)

Weekly Deaths by Age Group

# Plotting function
deathPlot4 <- function(area) {
  xx <- dd %>% 
    filter(Type == "Unweighted", Area == area)
  for(i in unique(xx$Age.Group)) {
    myMin <- min(xx %>% filter(Age.Group == i, Group == "<2020") %>%
                   pull(Number.of.Deaths), na.rm = T)
    xx <- xx %>% filter(!(Age.Group == i & Number.of.Deaths < myMin))
  }
  # Plot
  ggplot(xx, aes(x = Julian.Day, y = Number.of.Deaths, 
                 color = Group, alpha = Group)) +
    geom_line(aes(group = Year)) +
    facet_grid(. ~ Age.Group) +
    scale_color_manual(name = NULL, values = myColors) +
    scale_alpha_manual(name = NULL, values = c(0.4,0.8,0.8,0.8,0.8)) +
    theme_agData(legend.position = "bottom") +
    labs(title = area, x = "Julian Day", y = "Weekly Deaths", 
         caption = myCaption)
}

United States

mp <- deathPlot4(area = "United States")
ggsave("usa_deaths_4_01.png", mp, width = 12, height = 5)
ggsave("featured.png", mp, width = 12, height = 5)

New York

mp <- deathPlot4(area = "New York")
ggsave("usa_deaths_4_02.png", mp, width = 12, height = 5)

New Jersey

mp <- deathPlot4(area = "New Jersey")
ggsave("usa_deaths_4_03.png", mp, width = 12, height = 5)

California

mp <- deathPlot4(area = "California")
ggsave("usa_deaths_4_04.png", mp, width = 12, height = 5)

Texas

mp <- deathPlot4(area = "Texas")
ggsave("usa_deaths_4_05.png", mp, width = 12, height = 5)

Florida

mp <- deathPlot4(area = "Florida")
ggsave("usa_deaths_4_06.png", mp, width = 12, height = 5)

Washington

mp <- deathPlot4(area = "Washington")
ggsave("usa_deaths_4_07.png", mp, width = 12, height = 5)

Montana

mp <- deathPlot4(area = "Montana")
ggsave("usa_deaths_4_08.png", mp, width = 12, height = 5)

North Dakota

mp <- deathPlot4(area = "North Dakota")
ggsave("usa_deaths_4_09.png", mp, width = 12, height = 5)

South Dakota

mp <- deathPlot4(area = "South Dakota")
ggsave("usa_deaths_4_10.png", mp, width = 12, height = 5)

Yearly Deaths by Age Group

# Plotting function
deathPlot5 <- function(area) {
  # Prep data
  xx <- dd %>% 
    filter(Type == "Unweighted", Area == area, Year < 2022) %>%
    group_by(Year, Age.Group, Group) %>%
    summarise(Number.of.Deaths = sum(Number.of.Deaths, na.rm = T))
  # Plot
  ggplot(xx, aes(x = Year, y = Number.of.Deaths / 1000, 
                 fill = Group, alpha = Group)) +
    geom_bar(stat = "identity", color = "black") + 
    facet_grid(. ~ Age.Group) +
    scale_fill_manual(values = myColors) +
    scale_alpha_manual(values = c(0.4,0.8,0.8,0.8,0.8)) +
    scale_x_continuous(breaks = min(xx$Year):max(xx$Year)) +
    theme_agData(legend.position = "none",
                 axis.text.x = element_text(angle = 45, hjust = 1)) +
    labs(title = area, x = NULL, y = "Thousand Deaths", caption = myCaption)
}

United States

mp <- deathPlot5(area = "United States")
ggsave("usa_deaths_5_01.png", mp, width = 12, height = 5)

New York

mp <- deathPlot5(area = "New York")
ggsave("usa_deaths_5_02.png", mp, width = 12, height = 5)

New Jersey

mp <- deathPlot5(area = "New Jersey")
ggsave("usa_deaths_5_03.png", mp, width = 12, height = 4)

California

mp <- deathPlot5(area = "California")
ggsave("usa_deaths_5_04.png", mp, width = 12, height = 5)

Texas

mp <- deathPlot5(area = "Texas")
ggsave("usa_deaths_5_05.png", mp, width = 12, height = 5)

Florida

mp <- deathPlot5(area = "Florida")
ggsave("usa_deaths_5_06.png", mp, width = 12, height = 5)

Washington

mp <- deathPlot5(area = "Washington")
ggsave("usa_deaths_5_07.png", mp, width = 12, height = 5)

Montana

mp <- deathPlot5(area = "Montana")
ggsave("usa_deaths_5_08.png", mp, width = 12, height = 5)

North Dakota

mp <- deathPlot5(area = "North Dakota")
ggsave("usa_deaths_5_09.png", mp, width = 12, height = 5)

South Dakota

mp <- deathPlot5(area = "South Dakota")
ggsave("usa_deaths_5_10.png", mp, width = 12, height = 5)

Death Rates

# Prep data
xx <- dd %>% 
  filter(Year > 2019, Type == "Unweighted") %>%
  group_by(Area, State.Abbreviation, Date) %>%
  summarise(Number.of.Deaths = sum(Number.of.Deaths, na.rm = T)) %>%
  ungroup() %>% 
  left_join(pp, by = "Area") %>%
  mutate(Death.Rate = 1000000 * Number.of.Deaths / Population)
# Plot
mp <- ggplot(xx, aes(x = Date, y = Death.Rate)) +
  geom_line(color = "darkred", alpha = 0.8, size = 1) +
  facet_wrap(Area ~ .) +
  scale_color_manual(values = agData_Colors) +
  scale_x_date(date_labels = "%Y", date_breaks = "1 year") +
  theme_agData(axis.text.x = element_text(angle = 45, hjust = 1)) +
  labs(x = NULL, y = "Deaths per million people per week", 
       caption = myCaption)
ggsave("usa_deaths_6_01.png", mp, width = 12, height = 12)

North vs South Dakota

# Prep data
x1 <- xx %>% filter(State.Abbreviation %in% c("SD","ND"))
# Plot
mp <- ggplot(x1, aes(x = Date, y = Death.Rate, color = Area)) +
  geom_line(size = 1) +
  scale_color_manual(values = c("darkblue","steelblue")) +
  theme_agData(legend.position = "bottom") +
  labs(x = NULL, y = "Deaths per million people per week", 
       caption = myCaption)
ggsave("usa_deaths_6_02.png", mp, width = 6, height = 4)

California vs Texas

# Prep data
x1 <- xx %>% filter(State.Abbreviation %in% c("CA","TX"))
# Plot
mp <- ggplot(x1, aes(x = Date, y = Death.Rate, color = Area)) +
  geom_line(size = 1) +
  scale_color_manual(values = c("darkred","darkblue")) +
  theme_agData(legend.position = "bottom") +
  labs(x = NULL, y = "Deaths per million people per week", 
       caption = myCaption)
ggsave("usa_deaths_6_03.png", mp, width = 6, height = 4)

New York vs New Jersey vs Florida

# Prep data
colors <- c("darkred", "darkblue", "steelblue")
x1 <- xx %>% filter(State.Abbreviation %in% c("FL","NY","NJ"))
# Plot
mp <- ggplot(x1, aes(x = Date, y = Death.Rate, color = Area)) +
  geom_line(size = 1) +
  scale_color_manual(values = colors) +
  theme_agData(legend.position = "bottom") +
  labs(x = NULL, y = "Deaths per million people per week", 
       caption = myCaption)
ggsave("usa_deaths_6_04.png", mp, width = 6, height = 4)

All Data

# Prep data
xx <- dd %>% 
  filter(Type == "Unweighted",
         State.Abbreviation %in% c("FL","NY","NJ")) %>%
  group_by(Area, State.Abbreviation, Date) %>%
  summarise(Number.of.Deaths = sum(Number.of.Deaths, na.rm = T)) %>%
  ungroup() %>% 
  left_join(pp, by = "Area") %>%
  mutate(Death.Rate = 1000000 * Number.of.Deaths / Population)
# Plot
mp <- ggplot(xx, aes(x = Date, y = Death.Rate, color = Area)) +
  geom_line(size = 1) +
  scale_color_manual(values = colors) +
  scale_x_date(date_breaks = "1 year", date_label = "%Y") +
  theme_agData(legend.position = "bottom",
               axis.text.x = element_text(angle = 45, hjust = 1)) +
  labs(x = NULL, y = "Deaths per million people per week", 
       caption = myCaption)
ggsave("usa_deaths_6_05.png", mp, width = 6, height = 4)

© Derek Michael Wright www.dblogr.com/